home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / background.tcl.z / background.tcl
Text File  |  2002-07-08  |  13KB  |  478 lines
  1. #
  2. # exmh_background.tcl --
  3. #    Periodic background processing
  4. #
  5. # Copyright (c) 1993 Xerox Corporation.
  6. # Use and copying of this software and preparation of derivative works based
  7. # upon this software are permitted. Any distribution of this software or
  8. # derivative works must comply with all applicable United States export
  9. # control laws. This software is made available AS IS, and Xerox Corporation
  10. # makes no warranty about the software, its performance or its conformity to
  11. # any specification.
  12.  
  13. # Background processing
  14.  
  15. proc Background_Init {} {
  16.     global exmh env background
  17.  
  18.     if ![info exists env(MAIL)] {
  19.     set spool /usr/spool/mail/$env(USER)
  20.     } else {
  21.     set spool $env(MAIL)
  22.     }
  23.     Preferences_Add "Background Processing" \
  24. "A second process is used to perform various background tasks for Exmh.  These options control its behavior." \
  25.     [list \
  26.     { exmh(bgAsync) bgAsync ON {Separate background process}
  27. "This setting determines whether or not the background
  28. processing is done in a separate process or not.  A
  29. separate process causes less interference with the user
  30. interface, but might take up more machine resources."} \
  31.     { exmh(sendHack) sendHack ON {Keep xhost list clear}
  32. "The Tk send command will stop working if hosts are added to
  33. your xhost list, even if you are using Xauthority.  This option
  34. replaces the send command with a version that clears out the
  35. xhost list if hosts are found on it."} \
  36.     { exmh(background) bgAction {CHOICE off count msgchk flist inc hook} {Background processing}
  37. "exmh can periodically do some things for you:
  38. count - count new messages sitting in your spool file.
  39. msgchk - run the MH msgchk program.
  40. flist - check for new mail in all folders.
  41. inc - just like clicking the Inc button yourself.
  42. hook - suppply your own Hook_Background procedure.
  43. off - do nothing in the background."} \
  44.     { exmh(bgPeriod) bgPeriod 10 {Period (minutes)}
  45. "How often to do background task"} \
  46.     {exmh(bgNews) bgNews OFF {Background News Retrieval}
  47. "Retrieve News via NNTP in the background.  See the Preferences for 
  48. NNTP support for more information"} \
  49.     { exmh(bgNewsPeriod) bgNewsPeriod 60 {Period (minutes)}
  50. "How often to do background News Retrieval"} \
  51.     [list exmh(spool) bgSpool $spool {Mail spool pathname} \
  52. "Pathname for the mail spool file that gets new messages."] \
  53.     ]
  54.     # due to a TK bug I cannot trace the radio button variable directly.
  55.     # I can hack around it by tracing the bgPeriod, which is always
  56.     # set by Preferences because it is an entry
  57.     trace variable exmh(bgPeriod) w BackgroundFixup
  58.     if {$exmh(bgPeriod) <= 0} {
  59.         set exmh(bgPeriod) 10
  60.     }
  61.     set exmh(lastBackground) $exmh(background)
  62.  
  63.     set exmh(timeSinceBgNews) -1
  64.  
  65. if {0} {
  66.     if [catch {User_Layout} err] {
  67.         puts stderr "User_Layout: $err"
  68.     }
  69. }
  70.     set background(lastMsgChk) {}
  71.     set exmh(sendErrors) 0
  72.     if {$exmh(sendHack)} {
  73.     source $exmh(library)/send.tcl
  74.     }
  75. }
  76. proc Background_Startup {} {
  77.     global exmh inc
  78.  
  79.     if [info exists exmh(interp)] {
  80.     # Already in the background interpreter.
  81.     # Invoked because the style of background processing changed
  82.     Background_DoPeriodic
  83.     return
  84.     }
  85.     if [info exists exmh(bgInterp)] {
  86.     if {[catch {send $exmh(bgInterp) {Background_Startup}}] == 0} {
  87.         # Background interp already running
  88.         return
  89.     }
  90.     }
  91.     Background_Cleanup    ;# In case the bg process is really there anyway
  92.  
  93.     if {! $exmh(bgAsync) } {
  94.     # Do not run a separate process
  95.     Background_DoPeriodic
  96.     return
  97.     }
  98.     global mh_path argv0 wish
  99.     set prog ${argv0}-bg
  100.     Exmh_Status "Starting: $prog"
  101.     set cmd [list exec $wish -f $prog [winfo name .] $exmh(library) $mh_path &]
  102.     if [catch {
  103.     set pid [eval $cmd]
  104.     set exmh(bgPid) $pid
  105.     Exmh_Debug Background_Startup $exmh(background) pid $pid
  106.     after [expr 10*1000*60] BackgroundCheckup
  107.     } err] {
  108.     Exmh_Status "exmh-bg error: $err"
  109.     Background_DoPeriodic
  110.     }
  111. }
  112. proc BackgroundCheckup {} {
  113.     global exmh
  114.     Exmh_Debug BackgroundCheckup
  115.     if [BgLostPid $exmh(bgPid) exmh-bg] {
  116.     catch {unset exmh(bgInterp)}
  117.     Exmh_Debug Restarting exmh-bg
  118.     Background_Startup
  119.     } else {
  120.     after [expr 10*1000*60] BackgroundCheckup
  121.     }
  122. }
  123. proc Background_Register { bgInterp {bgPid junk} } {
  124.     # Invoked by the background interpreter so we can talk back to it
  125.     global exmh
  126.     set exmh(bgInterp) $bgInterp
  127.     if {$bgPid != "junk"} {
  128.     set exmh(bgPid) $bgPid
  129.     }
  130.     Exmh_Debug "Background interp is $bgInterp, pid $exmh(bgPid)"
  131.  
  132.     # Bundle up some parameters that could be overridden on the
  133.     # command line and so won't get picked up from the Xresources
  134.     set exmh(pid) [pid]        ;# TCL 7.* dependent
  135.     foreach varname {exmh(background) exmh(bgPeriod) exmh(pid)} {
  136.     lappend results [list $varname [set $varname]]
  137.     }
  138.     return $results
  139. }
  140. proc Background_Cleanup {} {
  141.     global exmh bgaction
  142.     if [catch {send $exmh(bgInterp) Exmhbg_Done [winfo name .]}] {
  143.     catch {exec kill $exmh(bgPid)}
  144.     }
  145.     catch {
  146.     foreach action [array names bgaction] {
  147.         BackgroundComplete $action
  148.     }
  149.     }
  150.     foreach interp [winfo interps] {
  151.     if {[string match $exmh(name)-bg* $interp]} {
  152.         catch {send $interp Exmhbg_Done [winfo name .]}
  153.     }
  154.     }
  155. }
  156. proc Background_DoPeriodic {} {
  157.     global exmh
  158.     Exmh_Debug Background_DoPeriodic $exmh(background)
  159.     switch -- $exmh(background) {
  160.     "count"  { set bgProc BackgroundCount }
  161.     "msgchk" { set bgProc BackgroundMsgChk }
  162.     "inc"    { set bgProc BackgroundInc }
  163.     "flist"  { set bgProc BackgroundFlist }
  164.     "hook"     {
  165.         set bgProc [info commands Hook_Background]
  166.         if {[string length $bgProc] == 0} {
  167.         Exmh_Status "Hook_Background undefined (hook background option)"
  168.         set exmh(background) off
  169.         }
  170.     }
  171.     default { set bgProc {} }
  172.     }
  173.     if {[string length $bgProc] != 0} {
  174.     if [catch $bgProc err] {
  175.         Exmh_Debug $bgProc $err
  176.     }
  177.     }
  178.  
  179.     if {$exmh(bgNews)} {
  180.     if {(($exmh(timeSinceBgNews) == -1) ||
  181.     ($exmh(timeSinceBgNews) > ($exmh(bgNewsPeriod) * 60)))} {
  182.         GetNews
  183.         set exmh(timeSinceBgNews) 0
  184.     } 
  185.     
  186.     incr exmh(timeSinceBgNews) [expr int($exmh(bgPeriod) * 60)]
  187.     }
  188.  
  189.     after [expr int($exmh(bgPeriod)*1000*60)] Background_DoPeriodic
  190. }
  191. proc Background_Off {} {
  192.     global exmh
  193.     set exmh(background) {}
  194. }
  195. proc BackgroundFixup { args } {
  196.     global exmh
  197.     Exmh_Debug BackgroundFixup $exmh(lastBackground) $exmh(background)
  198.     if {[catch {expr $exmh(bgPeriod)*1000*60}] ||
  199.      ($exmh(bgPeriod) <= 0)} {
  200.     set exmh(bgPeriod) 10
  201.     }
  202.     if {$exmh(background) != $exmh(lastBackground)} {
  203.     Background_Startup
  204.     set exmh(lastBackground) $exmh(background)
  205.     }
  206. }
  207.  
  208. proc BackgroundMsgChk {} {
  209.     global exmh env background
  210.     set result [Mh_MsgChk]
  211.     if {$result != $background(lastMsgChk)} {
  212.     BgRPC BackgroundMsgChkInner $result
  213.     Exmh_Status $result
  214.     set background(lastMsgChk) $result
  215.     }
  216. }
  217. proc BackgroundMsgChkInner {result} {
  218.     global background exmh
  219.     Exmh_Status $result
  220.     set background(lastMsgChk) $result
  221.     switch -glob -- $result {
  222.     "You have*" {set exmh(numUnInced) "Some"; Flag_Spooled}
  223.     "You don't*" {set exmh(numUnInced) 0; Flag_NoSpooled}
  224.     }
  225. }
  226. proc BackgroundCount {} {
  227.     global exmh env
  228.     if ![catch {Mh_MsgCount $exmh(spool)} newmsgs] {
  229.     BgRPC BackgroundNewMsgs [string trim $newmsgs]
  230.     }
  231. }
  232.  
  233. proc BackgroundNewMsgs { N } {
  234.     global exmh
  235.     if ![info exists exmh(numUnInced)] {
  236.     set exmh(numUnInced) 0
  237.     }
  238.     if {$N > 0} {
  239.     if {$N == 1} {
  240.         set msg "msg"
  241.     } else {
  242.         set msg "msgs"
  243.     }
  244.     set exmh(numUnInced) $N
  245.     Exmh_Status "You have $N spooled $msg" blue
  246.     Flag_Spooled
  247.     } else {
  248.     Flag_NoSpooled
  249.     if {$exmh(numUnInced) > 0} {
  250.         Exmh_Status ""
  251.     }
  252.     set exmh(numUnInced) $N
  253.     }
  254. }
  255. proc BackgroundInc {} {
  256.     Inc
  257. }
  258.  
  259. proc BackgroundFlist {} {
  260.     Flist_FindUnseen        ;# Update folder highlights
  261.     BgRPC Inc_PresortFinish    ;# Update scan listing
  262. }
  263.  
  264. # Invoke something in the background interpreter, if it exists
  265. proc BgAction { tag args } {
  266.     global exmh
  267.     Exmh_Debug BgAction $tag $args
  268.     Audit "$tag $args"
  269.     if [info exists exmh(bgInterp)] {
  270.     BackgroundPending $tag    ;# Register outstanding request
  271.     if ![catch {
  272.         send $exmh(bgInterp) [list after 1 [list BgProcess $tag $args]]
  273.     } err] {
  274.         return
  275.     }
  276.     BackgroundComplete $tag
  277.     Exmh_Debug BgAction $err
  278.     }
  279.     eval $args
  280.     foreach cmd [info commands Hook_Bg$tag*] {
  281.     $cmd
  282.     }
  283. }
  284. # Run something in the background and report back to the front end
  285. proc BgProcess { tag cmd } {
  286.     global exmh
  287.     if [catch $cmd err] {
  288.     Exmh_Status $err
  289.     }
  290.     if [catch {send $exmh(interp) [list BackgroundComplete $tag]} err ] {
  291.     catch {puts stderr "exmh-bg: BackgroundComplete($tag) failed: $err"}
  292.     Exmh_Status $err
  293.     }
  294. }
  295.  
  296. # Invoke a routine in the UI interpreter, if it exists, else ourselves.
  297. # If there is no separate background process, then
  298. # exmh(interp) does not exist, and we just eval the command
  299. # in the current process, which is already the UI.
  300. proc BgRPC { args } {
  301.     global exmh
  302.     if [info exists exmh(dead)] {
  303.     return
  304.     }
  305.     set check [info exists exmh(pid)]
  306.     if [info exists exmh(interp)] {
  307.     # Send command to main, front-end interpreter
  308.     set fail {}
  309. #    if {$check && [BgLostPid $exmh(pid) exmh]} {
  310. #        # Front-end died or may have restarted - bail out
  311. #        set fail "process $exmh(pid)"
  312. #    } else {
  313.         if [catch {send $exmh(interp) $args} err] {
  314.         switch -- $err {
  315.             {remote\ interpreter\ did\ not\ respond} {
  316.             if {$check && [BgLostPid $exmh(pid) exmh]} {
  317.                 set fail "process $exmh(pid)"
  318.             }
  319.             }
  320.             {no\ registered\ interpeter*} {
  321.             set fail "interp $exmh(interp)"
  322.             }
  323.             {no\ application\ named*} {
  324.             set fail "interp $exmh(interp)"
  325.             }
  326.             {} {
  327.             set fail "interp $exmh(interp)"
  328.             }
  329.             default {
  330.             #puts stderr "BgRPC: $args: $err"
  331.             }
  332.         }
  333.         } else {
  334.         return $err
  335.         }
  336. #    }
  337.     if {"$fail" != ""} {
  338.         unset exmh(interp)
  339.         catch {puts stderr "exmh-bg: lost UI $fail"}
  340.         exit
  341.     }
  342.     } else {
  343.     # Eval in main, front-end interpreter
  344.     uplevel #0 $args
  345.     }
  346. }
  347. proc BgLostPid { pid {name notused} } {
  348.     global exmh ps
  349.     if [catch {PsByID $pid} err] {
  350.     catch {puts stderr "BgLostPid $ps(cmd) $ps(pflag) $pid: $err"}
  351.     return 1
  352.     } else {
  353.     foreach line [split $err \n] {
  354.         if {[string compare [lindex $line 0] $pid] == 0} {
  355.         return 0
  356.         }
  357.     }
  358.     catch {puts stderr "BgLostPid pid $pid: cannot find in ps output"}
  359.     return 1
  360.     }
  361. }
  362. proc BgLostPidOld { pid {name notused} } {
  363.     if [catch {exec ps $pid} err] {
  364.     if [string match {[Uu]sage:*} $err] {
  365.         return [catch {exec ps -p $pid}]
  366.     } else {
  367.         return 1
  368.     }
  369.     } else {
  370.     foreach line [split $err \n] {
  371.         if {[string compare [lindex $line 0] $pid] == 0} {
  372.         return 0
  373.         }
  374.     }
  375.     return 1
  376.     }
  377. }
  378. # Improved version of BgLostPid thanks to Scott Hammond
  379. if {0} {
  380.     set ps ps
  381.     set ps_opt ""
  382.     proc BgLostPidClever { pid {name notused} } {
  383.     global ps ps_opt
  384.     if [catch "exec $ps $ps_opt $pid" err] {
  385.         #puts stderr "ps error: $err"
  386.         if [string match {[Uu]sage:*} $err] {
  387.         # got usage, so ps must be right, -p should also be right
  388.         set ps_opt "-p"
  389.         return [catch {exec $ps -p $pid}]
  390.         } elseif [string match {*can't find controlling terminal} $err] {
  391.         if {"$ps" == "ps"} {
  392.             set ps "/bin/ps"
  393.         } elseif {"$ps" == "/bin/ps"} {
  394.             set ps "/usr/ucb/ps"
  395.         } else {
  396.             return 1
  397.         }
  398.         return [BgLostPid $pid $name]
  399.         } else {
  400.         return 1
  401.         }
  402.     } else {
  403.         foreach line [split $err \n] {
  404.         if {[string compare [lindex $line 0] $pid] == 0} {
  405.             return 0
  406.         }
  407.         }
  408.         return 1
  409.     }
  410.     }
  411. }
  412.  
  413. proc Background_Preferences {} {
  414.     # Tell the background interpreter to update its per-user settings
  415.     global exmh
  416.     if [info exists exmh(bgInterp)] {
  417.     catch {send $exmh(bgInterp) [list Preferences_Reset]}
  418.     }
  419. }
  420.  
  421. proc BackgroundPending { action } {
  422.     global bgaction
  423.     set bgaction($action) 1
  424.     Exmh_Debug BackgroundPending $action
  425. }
  426. proc BackgroundComplete { action } {
  427.     global bgaction
  428.     catch {unset bgaction($action)}
  429.     Exmh_Debug BackgroundComplete $action
  430.     if [regexp {Refile (.*)} $action x folder] {
  431.     global exmh
  432.     if {[string compare $exmh(folder) $folder] == 0} {
  433.         Exmh_Status "Updating scan listing"
  434.         Scan_FolderUpdate $folder
  435.     }
  436.     }
  437.     if {[Background_Outstanding] == {}} {
  438.     Exmh_Status "background actions complete"
  439.     }
  440.     foreach cmd [info commands Hook_Bg$action*] {
  441.     $cmd
  442.     }
  443. }
  444. proc Background_Outstanding {} {
  445.     global bgaction background
  446.     if [catch {array names bgaction} actions] {
  447.     set actions {}
  448.     }
  449.     if {$actions == {}} {
  450.     set background(complete) 1
  451.     catch {destroy .ftoc.t.abort}
  452.     }
  453.     return $actions
  454. }
  455. proc Background_Wait {} {
  456.     global background
  457.     set background(complete) 0
  458.     set pending [Background_Outstanding]
  459.     if {$pending != {}} {
  460.     Exmh_Status "waiting... $pending"
  461.     catch {
  462.     button .ftoc.t.abort -text "Don't Wait" -command Background_Reset
  463.     place .ftoc.t.abort -relx .5 -rely .5 -anchor c
  464.     }
  465.     tkwait variable background(complete)
  466.     catch {destroy .ftoc.t.abort}
  467.     }
  468. }
  469.  
  470. proc Background_Reset {} {
  471.     global bgaction
  472.     foreach act [array names bgaction] {
  473.     Exmh_Status "Clearing $act"
  474.     }
  475.     unset bgaction
  476.     Background_Outstanding
  477. }
  478.